home *** CD-ROM | disk | FTP | other *** search
/ TeX 1995 July / TeX CD-ROM July 1995 (Disc 1)(Walnut Creek)(1995).ISO / macros / latex209 / contrib / slatex / codeset.ss < prev    next >
Text File  |  1993-11-07  |  8KB  |  225 lines
  1. ;codeset.ss
  2. ;SLaTeX Version 1.99
  3. ;Displays the typeset code made by SLaTeX
  4. ;(c) Dorai Sitaram, December 1991, Rice University
  5.  
  6. (define display-tex-line
  7.   (lambda (line)
  8.     (let loop ((i (if (flush-comment-line? line) 1 0)))
  9.       (let ((c (of line =char / i)))
  10.     (if (char=? c #\newline)
  11.         (if (eq? (of line =tab / i) &void-tab) 'skip
  12.         (newline *out*))
  13.         (begin (display c *out*) (loop (+ i 1))))))))
  14.  
  15. (define display-scm-line
  16.   (lambda (line)
  17.     (let loop ((i 0))
  18.       (let ((c (of line =char / i)))
  19.     (cond ((char=? c #\newline)
  20.            (let ((tab (of line =tab / i)))
  21.          (cond ((eq? tab &tabbed-crg-ret)
  22.             (display "\\\\" *out*) (newline *out*))
  23.                ((eq? tab &plain-crg-ret) (newline *out*))
  24.                ((eq? tab &void-tab)
  25.             (display "%" *out*) (newline *out*)))))
  26.           ((eq? (of line =notab / i) &begin-comment)
  27.            (display-tab (of line =tab / i) *out*)
  28.            (display c *out*)
  29.            (loop (+ i 1)))
  30.           ((eq? (of line =notab / i) &mid-comment)
  31.            (display c *out*)
  32.            (loop (+ i 1)))
  33.           ((eq? (of line =notab / i) &begin-string)
  34.            (display-tab (of line =tab / i) *out*)
  35.            (display "\\dt{" *out*)
  36.            (if (char=? c #\space)
  37.            (display-space (of line =space / i) *out*)
  38.            (display-tex-char c *out*))
  39.            (loop (+ i 1)))
  40.           ((eq? (of line =notab / i) &mid-string)
  41.            (if (char=? c #\space)
  42.            (display-space (of line =space / i) *out*)
  43.            (display-tex-char c *out*))
  44.            (loop (+ i 1)))
  45.           ((eq? (of line =notab / i) &end-string)
  46.            (if (char=? c #\space)
  47.            (display-space (of line =space / i) *out*)
  48.            (display-tex-char c *out*))
  49.            (display "}" *out*)
  50.            (loop (+ i 1)))
  51.           ((eq? (of line =notab / i) &begin-math)
  52.            (display-tab (of line =tab / i) *out*)
  53.            (display c *out*)
  54.            (loop (+ i 1)))
  55.           ((memq (of line =notab / i) (list &mid-math &end-math))
  56.            (display c *out*)
  57.            (loop (+ i 1)))
  58.           ((char=? c #\space)
  59.            (display-tab (of line =tab / i) *out*)
  60.            (display-space (of line =space / i) *out*)
  61.            (loop (+ i 1)))
  62.           ((char=? c #\')
  63.            (display-tab (of line =tab / i) *out*)
  64.            (display c *out*)
  65.            (if (or *in-qtd-tkn* (> *in-bktd-qtd-exp* 0)) 'skip
  66.          (set! *in-qtd-tkn* #t))
  67.            (loop (+ i 1)))
  68.           ((char=? c #\`)
  69.            (display-tab (of line =tab / i) *out*)
  70.            (display c *out*)
  71.            (if (or (null? *bq-stack*)
  72.              (of (car *bq-stack*) =in-comma))
  73.          (set! *bq-stack*
  74.            (cons (let ((f (make-bq-frame)))
  75.                (setf (of f =in-comma) #f)
  76.                (setf (of f =in-bq-tkn) #t)
  77.                (setf (of f =in-bktd-bq-exp) 0)
  78.                f)
  79.              *bq-stack*)))
  80.            (loop (+ i 1)))
  81.           ((char=? c #\,)
  82.            (display-tab (of line =tab / i) *out*)
  83.            (display c *out*)
  84.            (if (or (null? *bq-stack*)
  85.                (of (car *bq-stack*) =in-comma)) 'skip
  86.          (set! *bq-stack*
  87.            (cons (let ((f (make-bq-frame)))
  88.                (setf (of f =in-comma) #t)
  89.                (setf (of f =in-bq-tkn) #t)
  90.                (setf (of f =in-bktd-bq-exp) 0)
  91.                f)
  92.              *bq-stack*)))
  93.            (if (char=? (of line =char / (+ i 1)) #\@)
  94.            (begin (display-tex-char #\@ *out*) (loop (+ 2 i)))
  95.            (loop (+ i 1)))) 
  96.           ((memv c '(#\( #\[))
  97.            (display-tab (of line =tab / i) *out*)
  98.            (display c *out*)
  99.            (cond (*in-qtd-tkn* (set! *in-qtd-tkn* #f)
  100.                (set! *in-bktd-qtd-exp* 1))
  101.              ((> *in-bktd-qtd-exp* 0)
  102.               (set! *in-bktd-qtd-exp* (+ *in-bktd-qtd-exp* 1))))
  103.            (cond (*in-mac-tkn* (set! *in-mac-tkn* #f)
  104.                (set! *in-bktd-mac-exp* 1))
  105.              ((> *in-bktd-mac-exp* 0) ;is this possible?
  106.               (set! *in-bktd-mac-exp* (+ *in-bktd-mac-exp* 1))))
  107.            (if (null? *bq-stack*) 'skip
  108.          (let ((top (car *bq-stack*)))
  109.            (cond ((of top =in-bq-tkn)
  110.               (setf (of top =in-bq-tkn) #f)
  111.               (setf (of top =in-bktd-bq-exp) 1))
  112.              ((> (of top =in-bktd-bq-exp) 0)
  113.               (setf (of top =in-bktd-bq-exp)
  114.                 (+ (of top =in-bktd-bq-exp) 1))))))
  115.            (if (null? *case-stack*) 'skip
  116.          (let ((top (car *case-stack*)))
  117.            (cond ((of top =in-ctag-tkn)
  118.               (setf (of top =in-ctag-tkn) #f)
  119.               (setf (of top =in-bktd-ctag-exp) 1))
  120.              ((> (of top =in-bktd-ctag-exp) 0)
  121.               (setf (of top =in-bktd-ctag-exp)
  122.                 (+ (of top =in-bktd-ctag-exp) 1)))
  123.              ((> (of top =in-case-exp) 0)
  124.               (setf (of top =in-case-exp) 
  125.                 (+ (of top =in-case-exp) 1))
  126.               (if (= (of top =in-case-exp) 2)
  127.                 (set! *in-qtd-tkn* #t))))))
  128.            (loop (+ i 1)))
  129.           ((memv c '(#\) #\]))
  130.            (display-tab (of line =tab / i) *out*)
  131.            (display c *out*)
  132.            (if (> *in-bktd-qtd-exp* 0)
  133.          (set! *in-bktd-qtd-exp* (- *in-bktd-qtd-exp* 1)))
  134.            (if (> *in-bktd-mac-exp* 0)
  135.          (set! *in-bktd-mac-exp* (- *in-bktd-mac-exp* 1)))
  136.            (if (null? *bq-stack*) 'skip
  137.          (let ((top (car *bq-stack*)))
  138.            (if (> (of top =in-bktd-bq-exp) 0)
  139.                (begin
  140.             (setf (of top =in-bktd-bq-exp) 
  141.               (- (of top =in-bktd-bq-exp) 1))
  142.             (if (= (of top =in-bktd-bq-exp) 0)
  143.               (set! *bq-stack* (cdr *bq-stack*)))))))
  144.            (let loop ()
  145.          (if (null? *case-stack*) 'skip
  146.            (let ((top (car *case-stack*)))
  147.              (cond ((> (of top =in-bktd-ctag-exp) 0)
  148.                 (setf (of top =in-bktd-ctag-exp)
  149.                   (- (of top =in-bktd-ctag-exp) 1))
  150.                 (if (= (of top =in-bktd-ctag-exp) 0)
  151.                   (setf (of top =in-case-exp) 1)))
  152.                ((> (of top =in-case-exp) 0)
  153.                 (setf (of top =in-case-exp)
  154.                   (- (of top =in-case-exp) 1))
  155.                 (if (= (of top =in-case-exp) 0)
  156.                   (begin
  157.                    (set! *case-stack* (cdr *case-stack*))
  158.                    (loop))))))))
  159.            (loop (+ i 1)))
  160.           (else (display-tab (of line =tab / i) *out*)
  161.              (loop (do-token line i))))))))
  162.  
  163. (define do-token
  164.   (lambda (line i)
  165.     (let loop ((buf '()) (i i))
  166.       (let ((c (of line =char / i)))
  167.     (cond ((char=? c #\\ )
  168.            (loop (cons (of line =char / (+ i 1)) (cons c buf))
  169.              (+ i 2)))
  170.           ((or (memv c '(#\( #\) #\[ #\]
  171.               #\space #\newline
  172.               #\, #\@ #\;))
  173.            (memv c *math-triggerers*))
  174.            (output-token (list->string (reverse! buf)))
  175.            i)
  176.           ((char? c) (loop (cons (of line =char / i) buf) (+ i 1)))
  177.           (else (lerror 'do-token)))))))
  178.  
  179. (define output-token
  180.   (lambda (token)
  181.     (if (null? *case-stack*) 'skip
  182.       (let ((top (car *case-stack*)))
  183.     (if (of top =in-ctag-tkn)
  184.         (begin
  185.          (setf (of top =in-ctag-tkn) #f)
  186.          (setf (of top =in-case-exp) 1)))))
  187.     (if (assoc-token token special-symbols)
  188.     (display (cdr (assoc-token token special-symbols)) *out*)
  189.     (display-token token
  190.       (cond (*in-qtd-tkn* (set! *in-qtd-tkn* #f)
  191.           (cond ((equal? token "else") 'syntax)
  192.               ((data-token? token) 'data)
  193.               (else 'constant)))
  194.         ((data-token? token) 'data)
  195.         ((> *in-bktd-qtd-exp* 0) 'constant)
  196.         ((and (not (null? *bq-stack*))
  197.               (not (of (car *bq-stack*) =in-comma))) 'constant)
  198.         (*in-mac-tkn* (set! *in-mac-tkn* #f) 'syntax)
  199.         ((> *in-bktd-mac-exp* 0) (set-keyword token) 'syntax)
  200.         ((member-token token constant-tokens) 'constant)
  201.         ((member-token token variable-tokens) 'variable)
  202.         ((member-token token keyword-tokens)
  203.          (cond ((token=? token "quote") (set! *in-qtd-tkn* #t))
  204.                ((member-token token macro-definers)
  205.             (set! *in-mac-tkn* #t))
  206.                ((member-token token case-and-ilk)
  207.             (set! *case-stack*
  208.               (cons (let ((f (make-case-frame)))
  209.                   (setf (of f =in-ctag-tkn) #t)
  210.                   (setf (of f =in-bktd-ctag-exp) 0)
  211.                   (setf (of f =in-case-exp) 0)
  212.                   f)
  213.                 *case-stack*))))
  214.          'syntax)
  215.         (else 'variable))
  216.       *out*))
  217.     (if (and (not (null? *bq-stack*)) (of (car *bq-stack*) =in-bq-tkn))
  218.       (set! *bq-stack* (cdr *bq-stack*)))))
  219.  
  220. (define data-token?
  221.   (lambda (token)
  222.     ;token cannot be empty string!
  223.     (or (char=? (string-ref token 0) #\#)
  224.     (string->number token))))
  225.